home *** CD-ROM | disk | FTP | other *** search
/ Freelog 22 / freelog 22.iso / Prog / Djgpp / GPC2952B.ZIP / lib / gcc-lib / djgpp / 2.952 / units / fileutils.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-02-08  |  9.2 KB  |  268 lines
  1. {
  2. Some routines for file and directory handling on a higher level than
  3. those provided by the RTS.
  4.  
  5. Copyright (C) 2000-2001 Free Software Foundation, Inc.
  6.  
  7. Author: Frank Heckenbach <frank@pascal.gnu.de>
  8.  
  9. This file is part of GNU Pascal.
  10.  
  11. GNU Pascal is free software; you can redistribute it and/or modify
  12. it under the terms of the GNU General Public License as published by
  13. the Free Software Foundation; either version 2, or (at your option)
  14. any later version.
  15.  
  16. GNU Pascal is distributed in the hope that it will be useful,
  17. but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  19. GNU General Public License for more details.
  20.  
  21. You should have received a copy of the GNU General Public License
  22. along with GNU Pascal; see the file COPYING. If not, write to the
  23. Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  24. 02111-1307, USA.
  25.  
  26. As a special exception, if you link this file with files compiled
  27. with a GNU compiler to produce an executable, this does not cause
  28. the resulting executable to be covered by the GNU General Public
  29. License. This exception does not however invalidate any other
  30. reasons why the executable file might be covered by the GNU General
  31. Public License.
  32. }
  33.  
  34. {$gnu-pascal,B-,I-}
  35. {$if __GPC_RELEASE__ < 20000412}
  36. {$error This unit requires GPC release 20000412 or newer.}
  37. {$endif}
  38.  
  39. unit FileUtils;
  40.  
  41. interface
  42.  
  43. uses GPC;
  44.  
  45. type
  46.   TStringProc = procedure (const Name : String);
  47.  
  48. {
  49.   Finds all files matching the given Mask in the given Directory and
  50.   all subdirectories of it. The matching is done using all wildcards
  51.   and brace expansion, like MultiFileNameMatch does. For each file
  52.   found, FileAction is executed. For each directory found (including
  53.   `.' and `..' if they match the Mask!), DirAction is executed. If
  54.   MainDirFirst is True, this happens before processing the files in
  55.   the directory and below, otherwise afterwards. (The former is
  56.   useful, e.g., if this is used to copy a directory tree and
  57.   DirAction does a MkDir, while the latter behaviour is required
  58.   when removing a directory tree and DirAction does a RmDir.) Both
  59.   FileAction and DirAction can be nil in which case nothing is done
  60.   for files or directories found, respectively. (If DirAction is
  61.   nil, the value of DirsFirst does not matter.) Of course,
  62.   FileAction and DirAction may also be identical. The procedure
  63.   leaves InOutRes set in case of any error. If FileAction or
  64.   DirAction return with InOutRes set, FindFiles recognizes this and
  65.   returns immediately.
  66. }
  67. (*@@iocritical*)procedure FindFiles (const Directory, Mask : String; MainDirFirst : Boolean;
  68.                      FileAction, DirAction : TStringProc); asmname '_p_findfiles';
  69.  
  70. {
  71.   Creates the directory given by Path and all directories in between
  72.   that are necessary. Does not report an error if Path already
  73.   exists and is a directory, but, of course, if it cannot be created
  74.   because of missing permissions or because Path already exists as a
  75.   file.
  76. }
  77. (*@@iocritical*)procedure MkDirs (const Path : String); asmname '_p_mkdirs';
  78.  
  79. {
  80.   Removes Path if empty as well as any empty parent directories.
  81.   Does not report an error if Path is not empty.
  82. }
  83. (*@@iocritical*)procedure RmDirs (const Path : String); asmname '_p_rmdirs';
  84.  
  85. {
  86.   Copies the file Source to Dest, overwriting Dest if it exists and
  87.   can be written to. Returns any errors in IOResult. If Mode >= 0,
  88.   it will change the permissions of Dest to Mode immediately after
  89.   creating it and before writing any data to it. That's useful,
  90.   e.g., if Dest is not meant to be world-readable, because if you'd
  91.   do a ChMod after FileCopy, you would leave the data readable
  92.   (depending on the umask) during the copying. If Mode < 0, Dest
  93.   will be set to the same permissions Source has. In any case, Dest
  94.   will be set to the modification time of Source after coyping.
  95. }
  96. (*@@iocritical*)procedure FileCopy (const Source, Dest : String; Mode : Integer); asmname '_p_filecopy';
  97.  
  98. {
  99.   Creates a backup of FileName in the directory BackupDirectory or,
  100.   if BackupDirectory is empty, in the directory of FileName. Errors
  101.   are returned in IOResult, but if FileName does not exist, this
  102.   does *not* count as an error (i.e., BackupFile will just return
  103.   without setting IOResult then). If OnlyUserReadable is True, the
  104.   backup file will be given only user-read permissions, nothing
  105.   else.
  106.  
  107.   The name chosen for the backup depends on the Simple and Short
  108.   parameters. The short names will fit into 8+3 characters (whenever
  109.   possible), while the long ones conform to the conventions used by
  110.   most GNU tools. If Simple is True, a simple backup file name will
  111.   be used, and previous backups under the same name will be
  112.   overwritten (if possible). Otherwise, backups will be numbered,
  113.   where the number is chosen to be larger than all existing backups,
  114.   so it will be unique and increasing in chronological order. In
  115.   particular:
  116.  
  117.   Simple  Short  Backup name
  118.   True    True   Base name of FileName plus '.bak'
  119.   False   True   Base name of FileName plus '.b' plus a number
  120.   True    False  Base name plus extension of FileName plus '~'
  121.   False   False  Base name plus extension of FileName plus '.~', a
  122.                  number and '~'
  123. }
  124. (*@@iocritical*)procedure BackupFile (const FileName, BackupDirectory : String; Simple, Short, OnlyUserReadable : Boolean); asmname '_p_backupfile';
  125.  
  126. implementation
  127.  
  128. procedure FindFiles (const Directory, Mask : String; MainDirFirst : Boolean;
  129.                      FileAction, DirAction : TStringProc);
  130. var
  131.   Dir : DirPtr;
  132.   Name, FullName : TString;
  133. begin
  134.   Dir := OpenDir (Directory);
  135.   while InOutRes = 0 do
  136.     begin
  137.       Name := ReadDir (Dir);
  138.       if Name = '' then Break;
  139.       FullName := Directory + DirSeparator + Name;
  140.       if DirectoryExists (FullName) then
  141.         begin
  142.           if MainDirFirst and (@DirAction <> nil) and MultiFileNameMatch (Mask, Name) then
  143.             DirAction (FullName);
  144.           if (InOutRes = 0) and (Name <> DirSelf) and (Name <> DirParent) then
  145.             FindFiles (FullName, Mask, MainDirFirst, FileAction, DirAction);
  146.           if not MainDirFirst and (@DirAction <> nil) and MultiFileNameMatch (Mask, Name) then
  147.             DirAction (FullName)
  148.         end
  149.       else
  150.         if (@FileAction <> nil) and MultiFileNameMatch (Mask, Name) then
  151.           FileAction (FullName)
  152.     end;
  153.   CloseDir (Dir)
  154. end;
  155.  
  156. procedure MkDirs (const Path : String);
  157. var NewPath : TString;
  158. begin
  159.   if InOutRes <> 0 then Exit;
  160.   NewPath := DirFromPath (RemoveDirSeparator (Path));
  161.   if NewPath <> Path then MkDirs (NewPath);
  162.   if not DirectoryExists (Path) then MkDir (Path)
  163. end;
  164.  
  165. procedure RmDirs (const Path : String);
  166. var NewPath : TString;
  167. begin
  168.   if InOutRes <> 0 then Exit;
  169.   RmDir (Path);
  170.   { We use IOResult which clears the error status because an
  171.     error here should not be reported to the caller because
  172.     RmDir will fail for the first non-empty parent directory. }
  173.   if IOResult = 0 then
  174.     begin
  175.       NewPath := DirFromPath (RemoveDirSeparator (Path));
  176.       if NewPath <> Path then RmDirs (NewPath)
  177.     end
  178. end;
  179.  
  180. procedure FileCopy (const Source, Dest : String; Mode : Integer);
  181. var
  182.   Buf : array [1 .. $10000] of Byte;
  183.   BytesRead : (*@@fjf252  SizeType*)Cardinal;
  184.   f, g : File;
  185.   b : BindingType;
  186. begin
  187.   if InOutRes <> 0 then Exit;
  188.   Assign (f, Source);
  189.   Reset (f, 1);
  190.   b := Binding (f);
  191.   Assign (g, Dest);
  192.   Rewrite (g, 1);
  193.   if Mode < 0 then Mode := b.Mode;
  194.   ChMod ((*@@AnyFile*)AnyFile( g), Mode);
  195.   while not EOF (f) and (InOutRes = 0) do
  196.     begin
  197.       BlockRead (f, Buf, SizeOf (Buf), BytesRead);
  198.       BlockWrite (g, Buf, BytesRead)
  199.     end;
  200.   Close (f);
  201.   SetFileTime ((*@@AnyFile*)AnyFile( g), GetUnixTime (null), b.ModificationTime);
  202.   Close (g)
  203. end;
  204.  
  205. procedure BackupFile (const FileName, BackupDirectory : String; Simple, Short, OnlyUserReadable : Boolean);
  206. var
  207.   c, j, nr, r, Mode : Integer;
  208.   BackupPath, p, p1, p2, n, e, g : TString;
  209.   Buf : GlobBuffer;
  210. begin
  211.   if (InOutRes <> 0) or not FileExists (FileName) then Exit;
  212.   if OSDosFlag then
  213.     Short := True;
  214.   FSplit (FileName, p, n, e);
  215.   if BackupDirectory <> '' then
  216.     p := ForceAddDirSeparator (BackupDirectory);
  217.   if Short then
  218.     p := p + n
  219.   else
  220.     p := p + n + e;
  221.   if Simple then
  222.     if Short then
  223.       BackupPath := p + '.bak'
  224.     else
  225.       BackupPath := p + '~'
  226.   else
  227.     begin
  228.       if Short then
  229.         begin
  230.           p1 := p + '.b';
  231.           p2 := ''
  232.         end
  233.       else
  234.         begin
  235.           p1 := p + '.~';
  236.           p2 := '~'
  237.         end;
  238.       c := 0;
  239.       Glob (Buf, QuoteFileName (p1, WildCardChars) + '*' + p2);
  240.       for j := 1 to Buf.Result^.Count do
  241.         begin
  242.           g := Buf.Result^[j]^;
  243.           if IsPrefix (p1, g) then
  244.             begin
  245.               Delete (g, 1, Length (p1));
  246.               if IsSuffix (p2, g) then
  247.                 begin
  248.                   Delete (g, Length (g) - Length (p2) + 1, Length (p2));
  249.                   Val (g, nr, r);
  250.                   if r = 0 then c := Max (c, nr)
  251.                 end
  252.             end
  253.         end;
  254.       GlobFree (Buf);
  255.       repeat
  256.         Inc (c);
  257.         BackupPath := p1 + StringOfChar ('0', Ord (Short and (c < 10))) + Integer2String (c) + p2
  258.       until not FileExists (BackupPath)
  259.     end;
  260.   if OnlyUserReadable then
  261.     Mode := fm_UserReadable
  262.   else
  263.     Mode := - 1;
  264.   FileCopy (FileName, BackupPath, Mode)
  265. end;
  266.  
  267. end.
  268.